home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Belgian Amiga Club - ADF Collection
/
BS1 part 19.zip
/
BS1 part 19
/
PD 3.adf
/
Drw
/
drw.4th
< prev
next >
Wrap
Text File
|
1986-11-20
|
25KB
|
1,165 lines
\ Draw yer freqencies and synthesize em
\
\ get the binary speedy sin,cosine
Find Qsin.Spot Not IFTrue Include Qsin IfEnd
\ get 8SVX maker?
find 8svxmake.spot not IFTrue Include 8SVXMAke IFEnd
\ console support pack
find Consupp.spot not IFTrue Include Consupp IFEnd
\
\
Decimal
\
15000 Minimum.Object
512 tokens
anew Drw.spot
\
512 4 1array Accum
256 4 1array Phase
\
Variable N'p \ number of points in the record
Variable WN'p \ working number of points in the record
Variable WN'x \ working number of points in the record multiple
Variable K \ Bitwise resolution
\ Drw Loop Parms...
Variable B'Zd \ sample Delta
Variable B'Ze \ sample end
Variable B'Fs \ Low Freq ( as phase shift )
Variable B'Fe \ HighFreq ( ditto )
Variable B'Fd \ Freq delta ( = H-l/128 )
Variable F'Sz \ Size of the in-core block (64K)
Variable B'Zs \ BPF start
Variable B'Fk \ skip number for BPF
variable f'oct \ OCtaves for the file
\
Variable Shutup
Variable Played?
Variable Button
Variable Period
variable ccolor
Variable CDrmode
Variable HowLoud
\
hex 68 wconstant MDOWN \ these are returned in event message
E8 wconstant MUP decimal
\
Variable Dl'x
Variable Dl'y
\
Variable T'f \ working frequency
Variable T's \ sum register
Variable T'c \ sum register
Variable I' \ other index
variable LoopIx \ drawing loop indicies
Variable Flock \ frequency lock
\
Variable Fl'S \ floating scale...
Variable Fid \ file id for BPF
Variable BackX \ backup feature...
Variable Backy \ backup feature...
Variable CbaseXA \ Copy base
Variable CbaseXB \ Copy base
Variable CbaseYA \ Copy base
Variable CbaseYB \ Copy base
\
256 Constant Bwid
128 Constant BHei
30 Constant Bdown
Bdown 129 + Constant Bdown'
Bdown 128 + Constant Bdown''
5 Constant BLeft
Bleft 1+ Constant BLeft'
Bleft Bwid + Constant Bright
\ loopix box
bright 5+ Constant L'Left
l'left 10 + constant l'right
bdown constant L'top
bdown 40 + constant l'bot
\
\ define a custom screen, use defaults
\
Create DrwSTitle
0," Hey! I'm Dressing!"
Create DrwWTitle
0," Drw Window"
struct NewScreen DrwNs
DrwNs InitScreen \ copy default values to new screen
5 DrwNs +nsDepth W!
320 DrwNs +nsWidth W!
0 DrwNs +NsViewModes W!
struct NewWindow DrwNw \ define a window
Drwnw InitWindow \ copy default values to new window
0 Drwnw +nwLeftEdge w!
0 Drwnw +nwTopEdge w!
320 Drwnw +nwWidth w!
200 Drwnw +nwHeight w!
WINDOWSIZING WINDOWDRAG | WINDOWCLOSE | ACTIVATE |
Drwnw +nwFlags !
fCLOSEWINDOW MouseButtons |
RawKey | Drwnw +nwIDCMPFlags !
CUSTOMSCREEN Drwnw +nwType w! \ open on a custom screen
structend
\
Variable MODE
\
create TopMode$
0," D R W - D S P R B W I O Q "
create DoodleMode$
0," Doodle Mode "
create SynthMode$
0," Synth Mode "
create PlayMode$
0," Play Mode "
create WriteMode$
0," Write Mode "
create BPFMode$
0," Band Pass Mode "
create InputMode$
0," Input Mode "
create OutputMode$
0," Output Mode "
\
: Curx Currentwindow @ +wMouseX W@
;
: CurY Currentwindow @ +wMouseY W@
;
: ClipX
Dup BLeft < if drop bleft then
Dup Bright > if drop Bright then
;
: ClipY
dup bdown < if drop bdown then
dup bdown' > if drop bdown' then
;
: CurX'
CurX clipx
;
: CurY'
cury clipy
;
Variable CX'
Variable CY'
variable Vx
variable vy
\
Create T'Tx 8 allot
T'Tx 8 erase
: N'Text ( I X Y )
Locals| YY XX II |
II <# # # # # # # # # #> T'Tx swap Cmove
Rport 2 SetAPen
Rport XX yY Move
Rport T'Tx 8 Text drop
;
: N'Text2 ( I X Y )
Locals| YY XX II |
II <# # # # #> T'Tx swap Cmove
Rport 2 SetAPen
Rport XX yY Move
Rport T'Tx 3 Text drop
;
\
: Asc, [compile] Ascii , ;
?align4
create Xplan
Asc, Dot_ Asc, Line asc, Ramp asc, Thin asc, Blob
asc, Harm Asc, Avg_ asc, R-Up asc, R-Dn asc, Fill
asc, Fil2 asc, Dec_ asc, Inc_ asc, Xcld asc, -Cut
Asc, Dec0 asc, Inc0 asc, From asc, To__ asc, Copy
asc, .21. asc, AMmd asc, CpFr asc, CpTm asc, Lck1
asc, Lck2 asc, Lck4 asc, Lck8 asc, Vl02 asc, Vl01
asc, Vl00 asc, .32.
: getCmode
Cury 25 < If
Curx Bleft - 4 / 32 min 1 Max cdrmode !
cdrmode @ 280 20 N'text2
rport 240 20 Move
Rport 2 setapen
Rport CdrMode @ 1- 4* Xplan + 4 Text drop
Rport CColor @ Setapen \ goldarn ntext busted it
Mup Button !
then
;
: compcm
CdrMode @ 4* bleft + Locals| XX |
Rport 2 SetDrMd
Rport xx 18 xx 3+ 23 RectFill
Rport 1 setdrmd
;
\ Trace on
: LoopixShow
Loopix @ l'bot + 5-
Locals| Me |
Rport 2 setDrMd
rport l'left me move
rport l'right me draw
rport 1 setdrmd
Loopix @ negate 280 40 N'Text2
;
: GetLoopix
curx l'left l'right range swap drop if
\ oh boy: in range!
LoopixShow
cury 5+ l'bot - -31 max -1 min loopix !
loopixshow
then
;
: getccolor?
Cury 17 < If
curx bleft - 4 / 31 min 1 max ccolor !
Rport CColor @ SetAPen
Rport 140 12 160 23 RectFill
Mup Button !
Else
CompCM
GetCmode
CompCm
then
\ how bout somothose funny parms?
Cury bleft 30 - > If
GetLoopix
then
;
\
: EventPoll ( -- t/f ) \ true if any button hit
GetEvent
Case
MouseButtons Of ThisEvent +eCode W@ Button ! false
Mode @ 1 = if
Button @ Mdown = If getccolor? else BackX Off Backy off then
then
Endof
RawKey OF
ThisEvent +ecode W@
Case
[ hex ]
22 of 1 Mode ! true endof \ D fer doodle
21 of 2 Mode ! true endof \ s fer Synth
19 of 3 Mode ! true endof \ p fer Play
14 of 4 Mode ! true endof \ t fer Top
10 of 5 Mode ! true endof \ Q fer Quit
11 of 6 Mode ! true endof \ W for Write
35 of 7 Mode ! true endof \ B for BPF
13 of 8 Mode ! true endof \ R for Reset
17 of 9 Mode ! true endof \ I for input screen
18 of 0A Mode ! true endof \ O for output screen
[ decimal ] false
endcase
EndOf
fCLOSEWINDOW Of
\ ." CW "
5 mode ! true Endof
\ elsssee....
false
Endcase
;
Create FileName$ 41 allot
Variable F'
\
: GNum ( -- # ) \ read a # from keyboard
Begin 10 ask.Number until
;
: GetFileName
cr ." Filename?"
FileName$ 40 expect
0 FileName$ Cnt @ 1- + C!
cr
;
Create DrwConname
0," CON:10/10/300/150/D R W Input screen"
variable rf'sz
: GetBpfFileName
CurrentScreen @ ScreentoBack
DRWCOnName ZapDosCon
begin
cr ." Filename of a sound file?"
FileName$ 40 expect
0 FileName$ Cnt @ 1- + C!
FileName$ Open ?Dup
0= if ." Can't find that file??" cr false
else fid ! true then
until
\ other bpf stuff
." Sample start:" GNum B'Zs !
B'Zs @ B'Zd @ 8 scale + F'sz @ Min B'Ze !
." K :" Gnum K !
1 k @ Scale N'p !
fid @ filesize? 65536 Min RF'sz !
\ Read the sucker into the sound array...
F' @@ RF'Sz @ 0 Fid @ Read.Virtual
Fid @ Close
UnzapDosCon
CurrentScreen @ ScreenToFront
;
\
Decimal
: BigBegin
Shutup off
Mode Off
2 ccolor !
3 CdrMode !
-1 loopIx !
-10 HowLoud !
1 flock !
\ defaults for sampling
128 B'Zd !
B'Zd @ 8 scale B'ze !
512 B'FD !
4096 B'Fs !
BackX Off
BackY Off
B'Fs @ B'Fd @ 7 scale + B'Fe !
\ Size up the video pieces 256(x) by 128 (y)
65 1024 * F'SZ !
F'Sz @ Chip Get.Memory F' !
F' @ 0= IF False else True Then
;
decimal
: GetDrwParms
\ flip back the screen a spell...
currentscreen @ Screentoback
DRWConName ZapDosCOn
." Reset sample parms Mode... " cr
." Sample Delta(" B'Zd ? ." ):" GNum 256 min 1 max B'Zd !
B'Zd @ 8 scale 65536 Min B'Ze !
." Sample end is:" B'Ze ? cr
." Freq Delta(" B'Fd ? ." ):" Gnum b'Fd !
." Delta in Hz:" b'fd @ 3523 * -15 scale . cr
." Freq Start(" B'Fs ? ." ):" Gnum B'Fs !
." Start in Hz:" B'Fs @ 3523 * -15 scale . cr
B'Fs @ B'Fd @ 7 scale + B'Fe !
." Freq End in Hz:" B'Fe @ 3523 * -15 scale . cr
50 delay
3 mode !
UnzapDosCon
currentscreen @ screentofront
\ tell 'e the current freq etc.
B'Zd @ 20 190 n'text
B'Fs @ 120 190 n'text
B'FE @ 220 190 N'Text
;
\
create b> -4 allot \ Code B>
Hex
2017 w, \ d0 get,
4880 w, \ d0 byte ext,
48c0 w, \ d0 word ext,
2E80 w, \ d0 put,
361A W, 4eF6 W, 3018 W, \ next
Decimal
\ End-Code
\
{ a forth version...
Hex
: B> ( byte extend )
FF and dup 7F > if FFFFFF00 + then
;
Decimal
}
\
\
: okwindow? ( -- ) currentwindow @ 0= if
currentscreen @ CloseScreen
cr ." unable to open window! " abort then ;
\
: rgb \ r g b --n | packs color values
swap 16* or swap 8 scale or ; \ 16* is quick *, scale shifts bits
?align
create ctable \ table to store new colors
15 15 15 rgb w, 08 08 08 rgb w, 00 08 08 rgb w, 01 07 08 rgb w,
02 06 08 rgb w, 03 05 08 rgb w, 04 04 07 rgb w, 05 03 06 rgb w,
06 02 05 rgb w, 07 01 04 rgb w, 08 00 04 rgb w, 09 00 04 rgb w,
10 00 04 rgb w, 11 00 04 rgb w, 12 00 04 rgb w, 13 00 04 rgb w,
14 00 04 rgb w, 15 00 04 rgb w, 15 01 04 rgb w, 15 02 04 rgb w,
15 03 04 rgb w, 15 04 04 rgb w, 15 05 04 rgb w, 15 06 04 rgb w,
15 07 04 rgb w, 15 08 04 rgb w, 15 09 04 rgb w, 15 10 04 rgb w,
15 11 04 rgb w, 15 12 04 rgb w, 15 13 04 rgb w, 15 14 04 rgb w,
15 15 04 rgb w,
: loadcolors \ -- load new colors
currentwindow @ ViewPortAddress \ get ViewPort address
ctable \ color table address
32 \ number of colors to load
LoadRGB4 ; \ call to load color values
: PutUpScreen
DrwSTitle DrwNs +nsDefaultTitle !
DrwWTitle DrwNw +nwTitle !
DrwNs
OpenScreen
verifyscreen \ open a 4 bit plane screen
CurrentScreen @ DrwNw +nwScreen ! \ store screen ptr in window
DrwNw OpenWindow okwindow? \ open demo window
\ set the colors
loadcolors
;
\
: ShutUpScreen
Currentscreen @ ScreenTOBack
CurrentWindow @ CloseWindow
CurrentScreen @ CloseScreen
\ Release GM space
f' @ ?DUP IF To.Heap then
;
\
Variable lennn
Decimal
: N'Show ( Addr -- )
Locals| Add |
\ another display of the waveform
\ Rport 1 setapen
\ Rport bleft 180 17 - Bright 180 17 + Rectfill
256 0 DO
rport 1 setapen
rport bleft I+ 163 move
rport bleft I+ 197 draw
Rport 31 SetAPen
Rport Bleft I+
Add I+ C@ B> -3 scale 180 + WritePixel \ draw
Loop
;
Hex
: EndGame \ now quasi stereo
0 Locals| U- |
Button @ Mdown = IF
Played? On
F' @@ dup DFF0A0 ! DFF0B0 !
B'Ze @ 2/ dup DFF0A4 W! DFF0B4 W!
CurrentWindow @ +wMouseY W@ 2* 7c + 7c Max dup DFF0A6 W! DFF0B6 W! \ period
\ CurrentWindow @ +wMousex W@ 7c + 7c Max DFF0B6 W! \ period
3f Dff0A8 W! \ loudness
3f Dff0B8 W! \ loudness
\ fire away..
8203 Dff096 W! \ start DMA
else
\
Played? @ If
3 Dff096 W! \ Stop DMA
Then
Played? Off
then
\
;
Decimal
: PlayMode
CurrentWindow @ PlayMode$ -1 SetWindowTitles
Shutup off
Begin
\ display "mouse std freq in Hz (freq of a b'fd sized record)"
CurrentWindow @ +wMouseY W@ 2* 124 + 124 Max 170 20 n'text
Endgame
eventPoll Mode @ 3 = not and
until
;
: TopMode
0 0 locals| Z aa |
CurrentWindow @ TopMode$ -1 SetWindowTitles
32 1 do
Rport I SetAPen
Rport BLeft I 4* + 12 BLeft I 1+ 4* + 1- 16 RectFill
loop
\ move the comb over
33 1 do
rport 1 setapen
Rport Bleft I 4* + 17 bleft I 1+ 4* + 1- 23 Rectfill
rport 12 setapen
Rport Bleft I 4* + 1+ 17 bleft I 1+ 4* + 2- 23 Rectfill
loop
CompCm
\ draw the box
Rport 1 setApen
Rport BLeft Bdown Bright Bdown Bhei + 1+ RectFill
\ tell 'e the current freq etc.
B'Zd @ 20 190 n'text
B'Fs @ 120 190 n'text
B'FE @ 220 190 N'Text
\ draw the loopix box
rport l'left l'top l'right l'bot Rectfill
rport 16 setapen
rport l'left l'top move
rport l'left l'bot draw
rport l'right l'bot draw
rport l'right l'top draw
rport l'left l'top draw
rport 1 setapen
LoopixShow
Loopix @ negate 280 40 N'Text2
rport ccolor @ setapen
1 mode !
;
Decimal
: writeMode \ actually attempts to write 8SVX IFF file
CurrentWindow @ WriteMode$ -1 SetWindowTitles
CurrentScreen @ ScreentoBack
drwconname ZApdoscon
Getfilename
." Number Of Octaves??" Gnum 1 max 7 min f'Oct !
." Favorite Period (124-999)?" Gnum 124 max 999 min 3579546 swap / 8Hertz !
f' @@ B'Ze @ F'Oct @ Filename$ 8svxMake
if cr ." Successfully created!" else
cr ." Sorry, couldn't write it!" then 30 delay
unzapdoscon
CurrentScreen @ ScreenToFront
3 mode !
;
\
Variable zpot
Variable Pimp
Variable BLIP ascii Blip blip !
\
: full@
pimp 4 zpot @ Fid @ read.virtual
4 Zpot +! pimp @
;
: full!
4 zpot @ Fid @ write.virtual
4 zpot +!
;
\ structure for file: ID, time width,
\ frq lo, frq width, (samples)
\
: InputMode \ read screen file..
CurrentWindow @ InputMode$ -1 SetWindowTitles
CurrentScreen @ ScreentoBack
drwconname ZapDosCon
." Input a Screen File " cr
begin
Getfilename
Filename$ open dup fid !
0= if ." Can't find it! " cr then
fid @ 0= not until
UnzapDosCOn
CurrentScreen @ ScreenToFront
zpot off
\ get ye parms
full@ blip @ = if
full@ B'zd !
B'Zd @ 8 scale 65536 Min B'Ze !
full@ b'fs !
full@ b'fd !
B'Fs @ B'Fd @ 7 scale + B'Fe !
\ now read em
f' @@ f'sz @ zpot @ fid @ read.virtual
fid @ close
\ now show it
256 0 do
I 170 20 n'text
128 0 do
rport j 7 scale i+ f' @@ + C@ setapen
rport bleft j + bdown i+ writepixel
loop
loop
else
." That wasn't a good screen file " cr
fid @ close
then
3 mode !
\ tell me the current freq etc.
B'Zd @ 20 190 n'text
B'Fs @ 120 190 n'text
B'FE @ 220 190 N'Text
;
: OutputMode \ write screenfile
CurrentWindow @ OutputMode$ -1 SetWindowTitles
CurrentScreen @ ScreentoBack
drwconname ZapDosCon
." Output screen file name:" Cr
Getfilename
UnzapDoscon
CurrentScreen @ ScreenToFront
\ open it for write..
filename$ new.file fid !
fid @ 0= not if
zpot off
blip full!
b'zd Full!
b'fs full!
b'fd full!
\ now read off those pixels into f'
256 0 do
I 170 20 n'text
128 0 do
rport Bleft j + bdown i+ readpixel
j 7 scale i+ f' @@ + C!
loop
loop
\ now write f'
f' @@ f'sz @ zpot @ fid @ write.virtual
fid @ close
else
ioerror? @
." couldn't open it: code:" . cr
then
3 mode !
;
\
VAriable Tharm
Variable Ty
Variable Lx
Variable Px'
Variable Py'
Variable Rx
Variable Lcol
Variable Rcol
\
: doodleMode
0 Locals| Temp |
CurrentWindow @ DoodleMode$ -1 SetWindowTitles
begin
Curx Cx' !
CurY' FLock @ w/ FLock @ W* CY' !
CY' @ Bdown bdown' range swap drop
Cx' @ Bleft bright Range swap drop and IF
bdown' Cy' @ - B'fd @ * b'Fs @ + 3523 * -15 scale 170 20 n'text
cx' @ clipx Cx' !
Button @ MDown = If
rport ccolor @ setapen
Cdrmode @
Case
1 of \ mode 1 = just draw, fella
Rport CX' @ clipx CY' @ writePixel
endof
2 of \ draw via line, bub
Cx' @ BAckX @ > IF
cx' @ 1+ BackX !
rport vx @ Clipx vy @ move
Rport CX' @ clipx CY' @ clipy DRaw
cx' @ vx !
cy' @ vy !
then
endof
3 of \ ramp draw- add
CX' @ BackX @ > If
cx' @ 1+ BackX !
CColor @ to Temp
0 I' !
2 Temp do
Cx' @ I' @ - Clipx Lx !
Rport Lx @ Cy' @ readPixel i+ 31 min
Rport swap SetApen
Rport Lx @ Cy' @ WritePixel
Cx' @ I' @ + Clipx dup lx @ = if drop else
Lx !
Rport Lx @ Cy' @ readPixel i+ 31 min
Rport swap SetApen
Rport Lx @ Cy' @ WritePixel
then
1 i' +!
LoopIx @ +loop
then
endof
4 of
Rport CX' @ clipx CY' @ clipy CX' @ 1+ clipx CY' @ 5+ clipy RectFill
endof
5 of
Rport CX' @ 3- clipx CY' @ 3- clipy CX' @ 3+ clipx CY' @ 3+ clipy RectFill
endof
6 of \ HArmonix mode
Cx' @ Backx @ > IF
Backx @ 0= if cx' @ 1- backx ! cy' @ backy ! then
CX' @ BackX @ DO
I PX' !
\ interpolate Py from px
I BackX @ - Cy' @ Backy @ - * Cx' @ BAckx @ - / Backy @ + Py' !
\
Bdown' Py' @ - B'fd @ * B'fs @ + 8/ to temp \ CUrrent phase to temp
Temp Tharm !
BDown' Tharm @ B'Fs @ - B'Fd @ / - TY !
\ cr ." harm: " temp . ." :"
begin
ty @ bdown' < If
0 i' !
2 ccolor @ do
Px' @ i' @ - clipx Lx !
Rport Lx @ Ty @ readPixel i+ 31 min
rport swap setapen
Rport Lx @ Ty @ WritePixel \ write this one..
Px' @ i' @ + clipx dup lx @ = if drop else Lx !
Rport Lx @ Ty @ ReadPixel i+ 31 min
rport swap SetAPen
Rport Lx @ Ty @ WritePixel \ write this one..
then
1 i' +!
Loopix @ +loop
then
Temp Tharm +!
\ convert tharm to Ty
BDown' Tharm @ B'Fs @ - B'Fd @ / - TY !
\ ." (" Tharm @ . Ty @ . ." )"
Ty @ Bdown <
until
loop
Cx' @ BackX !
Cy' @ BackY !
then
endof
7 of \ average mode
0 to Temp
3 -2 do
Rport Cx' @ I + clipx Cy' @ ReadPixel temp + to Temp
loop
rport temp 5 / 1 max setapen
Rport Cx' @ 2- clipx Cy' @ Cx' @ 2+ clipx cy' @ RectFill
endof
8 of \ smear forward
Rport Cx' @ Cy' @ ReadPixel to Temp
0 I' !
2 Temp do
Rport I SetApen
Rport Cx' @ I' @ - dup bleft < if drop bleft then Cy' @ WritePixel
1 i' +!
LoopIx @ +loop
rport ccolor @ Setapen
endof
9 of \ smear backward
Rport Cx' @ Cy' @ ReadPixel to Temp
0 I' !
2 Temp do
Rport I SetApen
Rport Cx' @ I' @ + dup bright > if drop bright then Cy' @ WritePixel
1 i' +!
LoopIx @ +loop
rport ccolor @ Setapen
endof
10 of \ FLOOD ( all with the same as x-y become Apen )
rport cx' @ cy' @ readpixel to Temp
\ search left..
Cx' @ Dup Lx ! Rx !
begin
-1 Lx +!
Rport Lx @ Cy' @ ReadPixel Temp = not
LX @ Bleft < or
until
1 Lx +!
\ search right ..
begin
1 rx +!
Rport rx @ Cy' @ ReadPixel Temp = not
rX @ Bright > or
until
-1 Rx +!
\ redraw it
Rport Lx @ cy' @ move
Rport Rx @ Cy' @ Draw
endof
11 of \ ramp this line up
rport cx' @ cy' @ readpixel to Temp
\ search left..
Cx' @ Dup Lx ! Rx !
begin
-1 Lx +!
Rport Lx @ Cy' @ ReadPixel dup Lcol ! Temp = not
LX @ Bleft < dup if 2 lcol ! then or
Lcol @ 2 < or
until
\ search right ..
begin
1 rx +!
Rport rx @ Cy' @ ReadPixel Dup Rcol ! Temp = not
rX @ Bright > dup if 2 Rcol ! then or
rcol @ 2 < or
until
\ ." Lx:" Lx ? ." Rx:" Rx ? ." Lcol:" Lcol ? ." Rcol:" rcol ? cr
\ redraw .left.
cx' @ 1+ Lx @ do
rport Lcol @ 4* temp + 5 w/ dup Lcol ! Setapen
Rport I Cy' @ WritePixel
1 +loop
\ redraw right
cx' @ rx @ 1+ do
rport rcol @ 4* temp + 5 / dup rcol ! Setapen
Rport I Cy' @ WritePixel
-1 +loop
Rport ccolor @ Setapen \ whew
endof
12 of \ decrement
4 -3 do
Rport Cx' @ I+ clipx Cy' @ ReadPixel
Loopix @ + 1 max rport swap setapen
Rport Cx' @ I+ clipx Cy' @ writePixel
loop
rport CColor @ setapen
endof
13 of \ increment
4 -3 do
Rport Cx' @ I+ clipx Cy' @ ReadPixel
Loopix @ - 31 Min rport swap setapen
Rport Cx' @ I+ clipx Cy' @ writePixel
loop
rport CColor @ setapen
endof
14 of \ edible harmonie
cx' @ BackX @ >
cx' @ BackX @ 2+ < and Backx @ 0= or
IF ( only writes contiguous )
cx' @ BackX !
Bdown' Cy' @ - B'fd @ * B'fs @ + 8/ to temp \ CUrrent phase# to temp
Temp Tharm !
\ get the first corresponding y...
BDown' Tharm @ B'Fs @ - B'Fd @ / - clipY TY !
bdown'' lx !
\ cr ." harm: " temp . ." :"
rport 1 setapen
begin
ty @ i < If \ skip real low ones...
rport cx' @ lx @ Move
rport cx' @ ty @ 1+ Draw
Ty @ 1- lx !
then
\ next harmonic
Temp Tharm +!
\ convert tharm to Ty
BDown' Tharm @ B'Fs @ - B'Fd @ / - TY !
\ ." (" Tharm @ . Ty @ . ." )"
ty @ dup clipy ty ! bdown <
until
\ ." >"
\ get the top..
rport cx' @ lx @ move
rport cx' @ bdown Draw
\ ." <" cr
then
endof
15 of \ eliminat low freqs
256 0 do
I 170 20 n'text
128 0 do
rport Bleft j + bdown i+ readpixel
2 ccolor @ range if \ wipe out if from 2 to ccolor
drop Rport 1 setapen Rport bleft j + Bdown i+ Writepixel
else drop
then
loop
loop
endof
16 of \ decrement ( not 0 )
4 -3 do
4 -3 do
Rport Cx' @ I+ clipx Cy' @ J + clipy ReadPixel
dup 2 > if
Loopix @ + 2 max rport swap setapen
Rport Cx' @ I+ clipx Cy' @ j + Clipy writePixel
else
drop
then
loop
loop
rport CColor @ setapen
endof
17 of \ increment ( not 0 )
4 -3 do
4 -3 do
Rport Cx' @ I+ clipx Cy' @ j + ClipY ReadPixel
dup 1 > if
Loopix @ - 31 Min rport swap setapen
Rport Cx' @ I+ clipx Cy' @ J + Clipy writePixel
else drop
then
loop
loop
rport CColor @ setapen
endof
18 of \ set copy baseA...
Curx' CBAseXA !
cury' CbaseYA !
endof
19 of \ set copy baseb...
Curx' CBAseXB !
cury' CbaseYB !
endof
20 of \ actually copy
3 -2 do
3 -2 do
rport rport cx' @ i+ clipx cy' @ j + clipy readpixel setapen
\ now stomp it
Rport
cx' @ i+ clipx cbaseXa @ - CbaseXB @ + CLipx
cy' @ j + clipy cbaseYa @ - CbaseYB @ + CLipY WritePixel
loop
loop
endof
22 of \ Am modulate?
Bdown' Cy' @ - B'fd @ * B'fs @ + locals| Temp | \ CUrrent phase# to temp
Bright bleft do
14 temp I bleft - 2048 */ Xqsin -8 scale 15 +
Rport swap setapen
Rport I cy' @ WritePixel
loop
endof
23 of \ copy whole lines..
Bright Bleft DO
Rport I Cbaseya @ ReadPixel Rport Swap Setapen
Rport I Cy' @ WritePixel
loop
endof
24 of \ copy whole lines..
BDown' Bdown DO
Rport CbaseXA @ I ReadPixel Rport Swap Setapen
Rport CX' @ I WritePixel
loop
endof
25 of
1 flock !
endof
26 of 2 flock !
endof
27 of 4 flock !
endof
28 of 8 flock !
endof
29 of -10 HowLoud !
endof
30 of -11 HowLoud !
endof
31 of -12 HowLoud !
endof
endcase
Else \ up button
CdrMode @
Case
2 of
cx' @ clipx vx !
cy' @ clipy vy !
endof
endcase
then
then \ Cy' was too high?
eventpoll
until
;
{
: DisplayIt ( x y Z -- ) \ hope that amt not> 128
4/ 1+ 31 min
Rport swap SetAPen
rport rot rot WritePixel
;
}
\
create @-8Scale -4 allot \ Code @-8scale
hex
2057 w, \ a0 Get,
2010 w, \ A0 () d0 long Move,
E080 W, \ D0 8 # Long Asr,
2E80 W, \ d0 Put,
361A w, 4EF6 W, 3018 W, \ next
Decimal \ end-code
\
: ProcBPF
0 0 0 0 Locals| T# S: f: W: |
B'Ze @ B'Zd @ - F' @@ + to F:
B'Zs @ F' @@ + to S:
\ Do these little sub-loops, but ramp time before freq..
1 Wn'x !
Bdown'' Dl'Y !
N'P @ to W: \ Skip my nonsense ...
B'Fe @ B'Fs @ DO
I 3523 * -15 scale 170 20 n'text \ Standard freq display...
\ T'f @ I * 262143 and T'F ! \ scramble the phase somewhat..
t'f off
\
Bleft Dl'X !
\ set up wn'p =
{ skip more nonsense
262144 WN'X @ * i / dup N'P @ 2/ < If 1 wn'X +! then
Dup to W:
250 25 N'text \ freq is below time
}
\ Now go over the sample block at this frequency, LPF them
\
F: S: Do
\ freq = j..time = i
\
\ we gots to go slow here... cars is passing
\
T's Off
T'c Off
J I' !
\ Insert Assembler here ...
W: I+ I do
I c@ B> \ Get yer sample...
\
T'f @-8scale 2dup
XQSin t's +!
XQCOS t'c +!
I' @ T'F +! \ move the wave forward
loop
{
T'F @ I' @ W: I+ I
\ d0 d1 a1 a0
>CODE
A0 Pop, a1 Pop, D1 Pop, D0 Pop,
begin,
A0 )+ D2 Byte Move, \ D2 = M(I)
D2 Byte Ext, \ Extend somewhat
\ save this fer a second - probly oughta save all the registers!
d2 push,
\
\ --- incr freq,
d0 d1 long add, \ T'F = T'F + I'
a0 a1 long cmpa,
gt until,
>Forth
}
\
Rport T's @ W: W/ -6 scale dup W*
T'c @ W: W/ -6 scale dup W*
+ sqrt 4/ 1+ 31 min SetAPen
Rport Dl'X @ Dl'Y @ WritePixel { DisplayIt }
\
1 Dl'X +!
B'Zd @ +loop
-1 Dl'Y +!
\
\ BPFDone?
GetEvent
fCloseWindow = IF Leave then
B'Fd @ +loop \ next frequency
3 Mode !
;
: BPFMode
CurrentWindow @ BPFMode$ -1 SetWindowTitles
getbpfFilename
\ draw the box
Rport 2 setApen
Rport BLeft Bdown 1+ Bright 2- Bdown Bhei + RectFill
\ draw the loopix box
ProcBpf
;
Hex
Create ColtoByte \ somewhat stretched
\ 0 1 2 3 4 5 6 7
00 c, 00 c, 04 c, 08 c, 0c c, 10 c, 14 c, 18 c,
\ 8 9 10 11 12 13 14 15
1c c, 20 c, 24 c, 28 c, 2c c, 30 c, 34 c, 38 c,
\ 16 17 18 19 20 21 22 23
3c c, 40 c, 44 c, 48 c, 4c c, 50 c, 55 c, 59 c,
\ 24 25 26 27 28 29 30 31
5e c, 63 c, 68 c, 6d c, 72 c, 76 c, 7c c, 7f c,
Decimal
\
: SynthMode
CurrentWindow @ SynthMode$ -1 SetWindowTitles
0 0 0 0 0 0 0 Locals| Value Ovalue Sx Sy F-> IFreq JFaze |
Bleft to SX
F' @@ F'Sz @ Erase
F' @@ to F->
0 Phase Bhei 4* erase \ Phases of each of the sins
rport 2 SetDrMd
Rport 15 setapen
\
Bright Bleft DO \ for each column (time slice of b'zd samples)
Rport i 1+ Bdown Move
Rport I 1+ Bdown' Draw
0 Accum B'Zd @ 4* Erase \ zero out the special hi-res memory
\
B'fs @ to Ifreq
Bdown Bdown'' DO \ for each frequency ...
Rport J I ReadPixel ColToByte + C@
?dup If to Value
\ zero out the Accumulator Array...
\ sum up a sinwave (properly phased) at this amplitude
i Phase to JFaze
B'Zd @ 0 DO
Value JFaze @ -8 scale
XQsin I Accum +!
Ifreq JFaze +!
Loop
then
B'Fd @ Ifreq + to Ifreq
-1 +loop
\ now transfer the fourbyte values to the f-> array
\ ." --- Accum --- " cr
B'Zd @ 0 do
I Accum @
\ so i made it -5! I'm clipping, aint I?
\ -7 scale ( number of frequencies ) -5 scale
HowLoud @ scale
dup 127 > if drop 127 then
dup -127 < if drop -127 then F-> C!
F-> 1+ to F->
loop
\ cr
Rport i 1+ Bdown Move
Rport I 1+ Bdown' Draw
eventpoll if Mode @ 2 = not if leave then then \ stop me before I kill again..
Loop
3 Mode !
rport 1 setdrmd
;
\ This is the Main switching loop, exiting in each case
\ by hitting closegadget..
\
\
: ProcDrw
Mode Off
Begin
\ split up into subgroups they will stay there till their mode changes?
mode @ case
0 of TopMode endof
1 of doodleMode endof
2 of SynthMode endof
3 of PlayMode endof
4 of TopMode endof
6 of writemode endof
7 of BPFMode endof
8 of GetDrwParms endof
9 of InputMode endof
10 of outputmode endof
\ 5 = quit
endcase
Mode @ 5 =
until
\ drop \ we'll figger out why later...(figgered out??)
;
\
: Drw
Decimal
BigBegin
if
PutUpScreen
ProcDrw
ShutUpScreen \ and free core...
else
." I couldn't get core... " cr
then
?turnkey if bye else Depth IF ." funny depth:" depth . then abort then
;
\
." Drw is in " cr